home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr50 / cvgodpaf.zip / CVGODPAF.BAS next >
BASIC Source File  |  1993-06-11  |  4KB  |  81 lines
  1. 10  TITLE$ = "Convert GEN-ON-DISP Records to PAF"
  2. 20  COLOR 7,0: KEY OFF:CLS:DEFINT A-Z
  3. 30  LOCATE 5,40-INT(LEN(TITLE$)/2): PRINT TITLE$
  4. 40  LOCATE 25,1: PRINT " Press any key to continue";
  5. 50  K$= INKEY$: IF K$= "" THEN 50 ELSE CLS
  6. 51 '** OPEN FILES FOR TRANSFER
  7. 52 INPUT "Enter Disk Drive Letter where Gen-On-Disp PERSFILE and XFER.GED file will        reside. May be same as Transfer Program or another drive ", DR$: IF LEN(DR$)= 1 THEN DR$=DR$+":"
  8. 54 PERSPC$= DR$+"PERSFILE": XFRSPC$= DR$+"XFER.GED"
  9. 56 CLS: OPEN XFRSPC$ FOR APPEND AS 2
  10. 70 A$= "If data concerning the submitter is to be entered,":B$= "type in his name below and provide remaining information,":C$= "else press the ENTER Key to skip submitters data"
  11. 80 Z$=A$: GOSUB 150: LOCATE 2,MRGN: PRINT A$
  12. 90 Z$=B$: GOSUB 150: LOCATE 3,MRGN: PRINT B$
  13. 100 Z$=C$: GOSUB 150: LOCATE 4,MRGN: PRINT C$
  14. 110 D$= "SUBMITTERS DATA": E$=STRING$(14,45)
  15. 120 Z$=E$: GOSUB 150: LOCATE 6,MRGN:PRINT E$
  16. 130 Z$= D$:GOSUB 150: LOCATE 7,MRGN:PRINT D$
  17. 140 Z$=E$:GOSUB 150: LOCATE 8,MRGN:PRINT E$:GOTO 160
  18. 150 MRGN= 40-INT(LEN(Z$)/2): RETURN
  19. 160 LOCATE 10,15: PRINT"Submitter's Name: ";:LINE INPUT; SUBN$
  20. 170 IF SUBN$="" THEN CLS:GOTO 220
  21. 180 LOCATE 11,17: PRINT  "Address Line 1: ";:LINE INPUT; ADDR1$
  22. 190 LOCATE 12,17: PRINT  "Address Line 2: ";:LINE INPUT; ADDR2$
  23. 200 LOCATE 13,17: PRINT  "Address Line 3: ";:LINE INPUT; ADDR3$
  24. 210 LOCATE 14,17: PRINT  "Home Phone No.: ";:LINE INPUT; PHONE$
  25. 220 WR$= "0 HEAD": GOSUB 810
  26. 230 WR$= "1 SUBM": GOSUB 810
  27. 240 IF SUBN$="" THEN 300
  28. 250 WR$= "2 NAME "+SUBN$: GOSUB 810
  29. 260 WR$= "2 ADDR "+ADDR1$:GOSUB 810
  30. 270 WR$= "2 CONT "+ADDR2$:GOSUB 810
  31. 280 WR$= "2 CONT "+ADDR3$:GOSUB 810
  32. 290 WR$= "2 PHON "+PHONE$:GOSUB 810
  33. 300  CLS: OPEN PERSPC$  AS #1 LEN = 256
  34. 310  FIELD 1, 5 AS F1$, 20 AS F2$, 30 AS F3$, 2 AS F4$, 5 AS F5$, 5 AS F6$, 5 AS F7$, 11 AS F8$, 18 AS F9$, 16 AS F10$, 16 AS F11$, 11 AS F12$, 18 AS F13$, 16 AS F14$, 16 AS F15$, 11 AS F16$, 18 AS F17$, 16 AS F18$, 16 AS F19$
  35. 320  LOCATE 10,1: PRINT SPACE$(79): LOCATE 10,1
  36. 330  INPUT "Enter highest currently active Record No.", REC.NO
  37. 340 IF REC.NO=0 THEN '-** GOTO END OF PROGRAM **-
  38. 350 IF REC.NO>400 THEN LOCATE 12,1: PRINT SPACE$(79): LOCATE 12,1: PRINT "Numbermust be between 1 and 400--Re-enter No.": GOTO 330 ELSE LOCATE 12,1:PRINT SPACE$(79)
  39. 360 CLS:FOR I=1 TO REC.NO: GET #1, I
  40. 365 LOCATE 10,15: PRINT "PROCESSING RECORD NO. "; I
  41. 370 REM Extract information from the file for use
  42. 380 T1 = CVS(F1$): T1$=RIGHT$(STR$(T1),LEN(STR$(T1))-1)
  43. 390 WR$= "0 @"+T1$+"@INDI": GOSUB 810
  44. 400 TMP$=F2$: GOSUB 640  :T2$=TMP$
  45. 410 TMP$=F3$: GOSUB 640  :T3$=TMP$
  46. 420 WR$= "1 NAME "+T3$+" /"+T2$+"/": GOSUB 810
  47. 430 WR$= "1 SEX "+LEFT$(F4$,1): GOSUB 810
  48. 440 WR$= "1 RFN "+T1$: GOSUB 810
  49. 450 WR$= "1 BIRT": GOSUB 810
  50. 460 TMP$=F8$: GOSUB 680: WR$= "2 DATE "+TPY$: GOSUB 810
  51. 470 TMP$=F9$: GOSUB 640  :T9$=TMP$
  52. 480 TMP$=F10$: GOSUB 640  :T10$=TMP$
  53. 490 TMP$=F11$: GOSUB 640  :T11$=TMP$
  54. 500 WR$= "2 PLAC "+T9$+","+T10$+","+T11$: GOSUB 810
  55. 510 WR$= "1 DEAT": GOSUB 810
  56. 520 TMP$=F12$: GOSUB 680: WR$= "2 DATE "+TPY$: GOSUB 810
  57. 530 TMP$=F13$: GOSUB 640  :T13$=TMP$
  58. 540 TMP$=F14$: GOSUB 640  :T14$=TMP$
  59. 550 TMP$=F15$: GOSUB 640  :T15$=TMP$
  60. 560 WR$= "2 PLAC "+T13$+","+T14$+","+T15$: GOSUB 810
  61. 570 WR$= "1 BURI": GOSUB 810
  62. 580 TMP$=F16$: GOSUB 680: WR$= "2 DATE "+TPY$: GOSUB 810
  63. 590 TMP$=F17$: GOSUB 640  :T17$=TMP$
  64. 600 TMP$=F18$: GOSUB 640  :T18$=TMP$
  65. 610 TMP$=F19$: GOSUB 640  :T19$=TMP$
  66. 620 WR$= "2 PLAC "+T17$+","+T18$+","+T19$: GOSUB 810:NEXT I:WR$= "0 EOF": GOSUB 810:GOTO 820
  67. 630 '** RIGHT TRIM SUBROUTINE **
  68. 640 UL=LEN(TMP$): FOR J= 1 TO UL
  69. 650 IF RIGHT$(TMP$,1)= " " THEN TMP$= LEFT$(TMP$,LEN(TMP$)-1) ELSE J= UL
  70. 660 NEXT J: RETURN
  71. 670 ' ** CONVERT DATE FORMATS SUBROUTINE **
  72. 680 TPY$=RIGHT$(TMP$,4)
  73. 690 MO$="JanFebMarAprMayJunJulAugSepOctNovDec"
  74. 700 MM$=MID$(TMP$,4,3):MM=INSTR(MO$,MM$):MM=(MM+2)\3:MM$=RIGHT$(STR$(MM),LEN(STR$(MM))-1)
  75. 710 IF LEN(MM$)=1 THEN MM$="0"+MM$
  76. 720 TPY$=TPY$+MM$+LEFT$(TMP$,2)
  77. 730 RETURN
  78. 800 '** WRITE TO DISK SUBROUTINE **
  79. 810 PRINT #2, WR$: RETURN
  80. 820 CLOSE: CLS: COLOR 14,1,1: P$= "CONVERSION COMPLETE-SAVE XFER.GED TO A FLOPPY": Z$=P$: GOSUB 150: LOCATE 12,MRGN: PRINT P$: COLOR 7,0,0: BEEP
  81.